home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / compress / icelhab4 / ctl3d.bas next >
Encoding:
BASIC Source File  |  1995-05-01  |  6.8 KB  |  183 lines
  1. Option Explicit
  2. ' CTL3DV2 functions
  3. Declare Function Ctl3dAutoSubclass Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  4. Declare Function Ctl3dRegister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  5. Declare Function Ctl3dUnregister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  6. Declare Function Ctl3DSubClassDlgEx Lib "Ctl3DV2.DLL" (ByVal hInst As Integer, ByVal Flags As Long) As Integer
  7. Declare Function Ctl3dSubclassCtlEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, ByVal CntrlType As Integer) As Integer
  8. ' CTL3DV2 constants
  9. Global Const CTL3D_BUTTON_CTL = 0
  10. Global Const CTL3D_LISTBOX_CTL = 1
  11. Global Const CTL3D_EDIT_CTL = 2
  12. Global Const CTL3D_COMBO_CTL = 3
  13. Global Const CTL3D_STATIC_CTL = 4
  14.  
  15. ' API routines
  16. Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nOffset As Integer) As Integer
  17. Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
  18. Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
  19.  
  20. ' API Constants
  21. Global Const GWW_HINSTANCE = -6
  22. Global Const GWL_STYLE = -16
  23.  
  24. Global Const DS_MODALFRAME = &H80&
  25.     ' Frame types
  26. Global Const SS_BLACKFRAME = &H7&
  27. Global Const SS_GRAYFRAME = &H8&
  28. Global Const SS_WHITEFRAME = &H9&
  29.  
  30. Global Const WINDOW_BACKGROUND = &H80000005     ' Window background.
  31. Global Const BUTTON_FACE = &H8000000F           ' Face shading on command buttons.
  32. Global Const BUTTON_SHADOW = &H80000010         ' Edge shading on command buttons.
  33.  
  34. Global Const DONT_SUBCLASS = -1
  35.            
  36. Global hInstance As Integer
  37.  
  38. ' Again we MUST use the instance handle not the
  39. ' Module handle. See InitCTL3D for details
  40. Sub End3D ()
  41.     Dim iResult As Integer
  42.     ' Unregister with CTL3D
  43.     iResult = Ctl3dUnregister(hInstance)
  44. End Sub
  45.  
  46. ' Get the Instance Handle for this program. It MUST be used in place
  47. ' of the Module Handle to ensure programs running more than once
  48. ' will work correctly
  49. Function GetInstance (oFrm As Form)
  50.     GetInstance = GetWindowWord(oFrm.hWnd, GWW_HINSTANCE)
  51. End Function
  52.  
  53. ' Show a ThreeD dialog
  54. Sub Make3D (Frm As Form)
  55.     Dim iResult As Integer, iCTRL As Integer
  56.     Dim iType As Integer, bColour As Integer, cLabel As String
  57.     Dim lStyle As Long
  58.     If Frm.BorderStyle = 3 Then
  59.     ' Set the Windows style bits to make CTL3D paint
  60.     ' the border as well as the client area
  61.     lStyle = GetWindowLong((Frm.hWnd), GWL_STYLE)
  62.     lStyle = lStyle Or DS_MODALFRAME
  63.     lStyle = SetWindowLong((Frm.hWnd), GWL_STYLE, lStyle)
  64.     End If
  65.     Frm.BackColor = BUTTON_FACE
  66.     ' Activate CTL3D for this window, since VB doesn't use true
  67.     ' Dialogs you must tell it to do it yourself
  68.     iResult = Ctl3DSubClassDlgEx((Frm.hWnd), 0&)
  69.     ' Since VB has already subclassed the controls to 'THUNDER' controls
  70.     ' CTL3D will not touch them. So we must walk through the controls and
  71.     ' tell it what class to subclass them as
  72.     For iCTRL = 0 To Frm.Controls.Count - 1
  73.     ' Start by assuming we won't subclass the control
  74.     iType = DONT_SUBCLASS
  75.     ' Used to store a fake label used in frames
  76.     cLabel = ""
  77.     ' and not change it's back color
  78.     bColour = False
  79.     ' Lets find the type of the control
  80.     If TypeOf Frm.Controls(iCTRL) Is OptionButton Then
  81.         ' Colour it and Subclass it as a button
  82.         bColour = True
  83.         iType = CTL3D_BUTTON_CTL
  84.     ElseIf TypeOf Frm.Controls(iCTRL) Is CheckBox Then
  85.         ' Colour it and Subclass it as a button
  86.         bColour = True
  87.         iType = CTL3D_BUTTON_CTL
  88.     ElseIf TypeOf Frm.Controls(iCTRL) Is CommandButton Then
  89.         ' Colour it and Subclass it as a button
  90.         bColour = True
  91.         iType = CTL3D_BUTTON_CTL
  92.     ElseIf TypeOf Frm.Controls(iCTRL) Is ListBox Then
  93.         ' Colour it and Subclass it as a listbox
  94.         bColour = True
  95.         iType = CTL3D_LISTBOX_CTL
  96.     ElseIf TypeOf Frm.Controls(iCTRL) Is FileListBox Then
  97.         ' Colour it and Subclass it as a listbox
  98.         bColour = True
  99.         iType = CTL3D_LISTBOX_CTL
  100.     ElseIf TypeOf Frm.Controls(iCTRL) Is DirListBox Then
  101.         ' Colour it and Subclass it as a listbox
  102.         bColour = True
  103.         iType = CTL3D_LISTBOX_CTL
  104.     ElseIf TypeOf Frm.Controls(iCTRL) Is PictureBox Then
  105.         ' for picture boxes i've decided to only subclass
  106.         ' if there is a border, otherwise I set it's back colour
  107.         ' This gives white 3D pictures or a grey panel which
  108.         ' can be used to group controls such as OptionButtons
  109.         If Frm.Controls(iCTRL).BorderStyle Then
  110.         iType = CTL3D_LISTBOX_CTL
  111.         Else
  112.         bColour = True
  113.         End If
  114.         If Frm.Controls(iCTRL).Tag <> "" Then
  115.         cLabel = Frm.Controls(iCTRL).Tag
  116.         End If
  117.     ElseIf TypeOf Frm.Controls(iCTRL) Is TextBox Then
  118.         ' Don't color text boxes but Subclass them as Edit controls
  119.         iType = CTL3D_EDIT_CTL
  120.     ElseIf TypeOf Frm.Controls(iCTRL) Is ComboBox Then
  121.         ' Don't color ComboBoxes but subclass them as COMBO controls
  122.         iType = CTL3D_COMBO_CTL
  123.     ElseIf TypeOf Frm.Controls(iCTRL) Is DriveListBox Then
  124.         ' Don't color DriveListBoxes but subclass them as COMBO controls
  125.         iType = CTL3D_COMBO_CTL
  126.     ElseIf TypeOf Frm.Controls(iCTRL) Is Frame Then
  127.         ' Colour and Subclass them as Buttons controls
  128.         ' Yes, windows calls Frames buttons!
  129.         bColour = True
  130.         iType = CTL3D_BUTTON_CTL
  131.     ElseIf TypeOf Frm.Controls(iCTRL) Is Label Then
  132.         ' Colour but don't subclass a label
  133.         bColour = True
  134.     End If
  135.     ' Set the BackColor as required
  136.     If bColour Then
  137.         Frm.Controls(iCTRL).BackColor = BUTTON_FACE
  138.     End If
  139.     ' Produce a fake label that will survive a 3D Frame
  140.     If cLabel <> "" Then
  141.         Frm.Controls(iCTRL).Print cLabel
  142.     End If
  143.     ' Subclass the control as required
  144.     If iType <> DONT_SUBCLASS Then
  145.         ' Pass it the Controls hWnd and type type required
  146.         iResult = Ctl3dSubclassCtlEx((Frm.Controls(iCTRL).hWnd), iType)
  147.     End If
  148.     Next
  149.     ' Display the form, I'm using Modal in this example but it's not required
  150.     Frm.Show 1
  151. End Sub
  152.  
  153. ' Call this routine from the MouseUp event of the OptionButton
  154. ' to ensure you the 3D painting is correct.
  155. Sub PaintRadio (obWas As OptionButton, obNew As OptionButton)
  156.     ' Repaint the control being activated
  157.     obNew.Refresh
  158.     ' We must do it twice to ensure the focus rect
  159.     ' is painted correctly (It doesn't work with one!)
  160.     obNew.Refresh
  161.     ' If these are two different controls then update
  162.     ' the one that used to be set
  163.     If obWas.hWnd <> obNew.hWnd Then
  164.     ' Only one update is required for this one
  165.     ' since it doesn't have the focus
  166.     obWas.Refresh
  167.     End If
  168. End Sub
  169.  
  170. ' Register with CTL3D. You must register with an instance
  171. ' handle NOT the module handle, you will cause GPF's when
  172. ' running multiple instances of your program.
  173. Sub Start3D ()
  174.     Dim iResult As Integer
  175.     ' Register with CTL3D
  176.     iResult = Ctl3dRegister(hInstance)
  177.     If iResult Then
  178.     ' Make MSGBoxes and Common dialogs 3D
  179.     iResult = Ctl3dAutoSubclass(hInstance)
  180.     End If
  181. End Sub
  182.  
  183.